perm filename LISS.F4[JC,MUS] blob sn#017004 filedate 1972-12-20 generic text, type T, neo UTF8
	SUBROUTINE SPACE4(AMP,RAMP,DOP,CHNA,CHNB,CHNC,CHND,ARRAY)
	DIMENSION AMP(512),RAMP(512),DOP(512),
	1 CHNA(512),CHNB(512),CHNC(512),CHND(512)
	DIMENSION F(7),G(3)
     	DIMENSION ARRAY(2,600),B(4),C(3),D(4),E(7)
	DIMENSION ST(50),SU(350)
	DATA (B(I),I=1,3)/'A TO B IN FT.'/
	DATA (C(I),I=1,3)/'LISS=1,LINE=2'/
	DATA (D(I),I=1,3)/'0=FIN,1=REDEF'/
	DATA (E(I),I=1,6)/'SEE AMP=1,DOP=2,STER1=3 OR 0'/
	DATA (F(I),I=1,6)/'X,Y,RAD OR X1,Y1,X2,Y2,X3,Y3'/
	DATA (G(I),I=1,2)/'CYCL TM='/
	CALL TYPLOC(-300,-512)
101	CONTINUE
C	CALL CLEAR
	CALL DPYSET(1,ST,50)
	CALL DPYBRT(1)
	CALL AIVECT(0,0)
	CALL HYDPOG(1)
	IF(KT1.EQ.1)KT1=513
	IY=100
	DO 11 I=1,2
	CALL ALINE(-100,IY,100,IY)
11	IY=-IY
	IX=100
	DO 12 I=1,2
	CALL ALINE(IX,-100,IX,100)
12	IX=-IX
	CALL ALINE(0,0,0,100)
	CALL DPYOUT(1)
CC  SPACE DEFINITION FINISHED
	CALL MESS(B)
	CALL RDNUM(DIS)
	DELTA=DIS/100.0
	CALL MESS(C)
	CALL RDNUM(XNUM)
	IF(XNUM.EQ.0.0)GO TO 20
	L=XNUM
	CALL DPYSET(2,SU,350)
	CALL DPYBRT(6)
	CALL AIVECT(0,0)
	CALL MESS(F)
	GO TO (1,2,2),L
1	CALL RDNUM(XCO)
	CALL RDNUM(YCO)
	CALL RDNUM(RADIUS)
	RADNS=(2.0*3.1415927)/512.0
	CRADNS=RADNS
	IL=1
36	CONTINUE
	SINR=SIN(CRADNS)
	COSR=COS(CRADNS)
	CRADNS=CRADNS+RADNS
	ARRAY(1,IL)=SINR*RADIUS+XCO
	ARRAY(2,IL)=COSR*RADIUS+YCO
	GO TO 520
2	CALL RDNUM(XCO1)
	CALL RDNUM(YCO1)
	CALL RDNUM(FREQX)
	CALL RDNUM(PHASX)
      	CALL RDNUM(FREQY)
	CALL RDNUM(PHASY)
	CALL RDNUM(FREQ2X)
	CALL RDNUM(PHAS2X)
	CALL RDNUM(FREQ2Y)
	CALL RDNUM(PHAS2Y)
	CALL RDNUM(DIA)
	CALL RDNUM(DIA2)
	IF(L.EQ.3)GOTO 3
	XINC=(FREQX*360.)/512.
	XINC2=(FREQ2X*360.)/512.
	XK=-XINC+PHASX
	XK2=-XINC2+PHAS2X
	YINC=(FREQY*360.)/512.
	YINC2=(FREQ2Y*360.)/512.
	YK=-YINC+PHASY
	YK2=-YINC2+PHAS2Y
	IL=1
37	CONTINUE
	XX=XK+XINC
	XX2=XK2+XINC2
	IF(XX.GE.360.)XX=XX-360.
	IF(XX2.GE.360.)XX2=XX2-360.
	XK=XX
	XK2=XX2
	YY=YK+YINC
	YY2=YK2+YINC2
	IF(YY.GE.360.)YY=YY-360.
	IF(YY2.GE.360.)YY2=YY2-360.
	YK=YY
	YK2=YY2
	ARRAY(1,IL)=XCO1+SIND(XX)*DIA+(SIND(XX2)*DIA2)
	ARRAY(2,IL)=YCO1+SIND(YY)*DIA+(SIND(YY2)*DIA2)
	GO TO 520
3	CALL RDNUM(XCO3)
	CALL RDNUM(YCO3)
	XDIF1=XCO2-XCO1
	XDIF2=XCO3-XCO2
	YDIF1=YCO2-YCO1
	YDIF2=YCO3-YCO2
	XCO4=XCO2+XDIF2-XDIF1
	YCO4=YCO2+YDIF2-YDIF1	
	XCOI1=XDIF1/128.
	XCOI2=XDIF2/128.
	YCOI1=YDIF1/128.
	YCOI2=YDIF2/128.
C	XCO1=XCO1-XCOI1
C	YCO1=YCO1-YCOI1
	IL=1
32	IF(IL.GT.128)GO TO 33
	ARRAY(1,IL)=XCO1+XCOI1
	ARRAY(2,IL)=YCO1+YCOI1
	XCO1=ARRAY(1,IL)
	YCO1=ARRAY(2,IL)
	GO TO 520
33	IF(IL.GT.256.)GO TO 34
	ARRAY(1,IL)=XCO2+XCOI2
	ARRAY(2,IL)=YCO2+YCOI2
	XCO2=ARRAY(1,IL)
	YCO2=ARRAY(2,IL)
	GO TO 520
34	IF(IL.GT.384)GO TO 35
	ARRAY(1,IL)=XCO3-XCOI1
	ARRAY(2,IL)=YCO3-YCOI1
	XCO3=ARRAY(1,IL)
	YCO3=ARRAY(2,IL)
	GO TO 520
35	ARRAY(1,IL)=XCO4-XCOI2
        ARRAY(2,IL)=YCO4-YCOI2
	XCO4=ARRAY(1,IL)
	YCO4=ARRAY(2,IL)
520	NEWX=ARRAY(1,IL)
	NEWY=ARRAY(2,IL)
	IF(IL.GT.1)GO TO 503
	CALL AIVECT(NEWX,NEWY)
	GO TO 504
503	CALL SVECT(NEWX-IOLDX,NEWY-IOLDY)
504	IOLDX=NEWX
	IOLDY=NEWY
	CALL DPYOUT(2)
	IL=IL+1
	IF(IL.GT.512)GO TO 500
	GO TO (36,37,32),L
500	CONTINUE
	M=512
	CALL MESS(G)
	CALL RDNUM(SPD1)
	SPD1=60.0/((1.0/SPD1)*512.0)
	GO TO 501
20	SPD1=SPD
C	CALL POS(ARRAY,600,M,SPD1)
501	X=M-1
	AI=X/512.0
	BI=2.0
	S=60.0/SPD1
	R=SQRT(ARRAY(1,1)**2+ARRAY(2,1)**2)
	DO 100 J=1,512
	I=BI
	X=ARRAY(1,I)
	Y=ARRAY(2,I)
	BI=BI+AI
	R1=SQRT(X**2+Y**2)
	AMP(J)=DIS/(R1*DELTA)
	RAMP(J)=ALOG(DIS)/ALOG(R1*DELTA)
	IF(RAMP(J).GT.1.)RAMP(J)=1.
	CONTINUE
	VR=S*DELTA*(R1-R)
	XJ=J
	IF((R1.EQ.R).AND.(XJ.GT.1.0))GO TO 31
	DOP(J)=1180.0/(1180.0+VR)
	GO TO 21
31	DOP(J)=DOP(J-1)
21	R=R1
	CONTINUE
	AX=ABS(X)
	AY=ABS(Y)
	PI=3.1416
	ANGLE=AMOD(ATAN2(Y,X)+6.2832,6.2832)	
	PI2=PI/2.0
	IF((AX.LE.AY).AND.(Y.GT.0.0))GO TO 2000
	IF((AX.GT.AY).AND.(X.GT.0.0))GO TO 2001
	IF((AX.LE.AY).AND.(Y.LT.0.0))GO TO 2002
	CHN=ANGLE-(3.*PI)/4.	
	CHNB(J)=1.-CHN/PI2	
	CHNC(J)=CHN/PI2	
	CHNA(J)=0.0
	CHND(J)=0.0
	GO TO 100	
2000	CHN=ANGLE-PI/4.
	CHNA(J)=1.-CHN/PI2	
	CHNB(J)=CHN/PI2	
	CHNC(J)=0.0
	CHND(J)=0.0
	GO TO 100	
2001	CHN=ANGLE-(7.*PI)/4.	
	IF(ANGLE.LT.PI/4.)CHN=ANGLE+PI/4.
	CHND(J)=1.-CHN/PI2	
	CHNA(J)=CHN/PI2	
	CHNB(J)=0.0
	CHNC(J)=0.0
	GO TO 100	
2002	CHN=ANGLE-(5.*PI)/4.	
	CHNC(J)=1.-CHN/PI2	
	CHND(J)=CHN/PI2	
	CHNA(J)=0.0
	CHNB(J)=0.0
100	CONTINUE
	DO 402 JK=1,512
	CHNA(JK)=SQRT(CHNA(JK))
	CHNB(JK)=SQRT(CHNB(JK))
	CHNC(JK)=SQRT(CHNC(JK))
	CHND(JK)=SQRT(CHND(JK))
402	CONTINUE
	CALL INTERP(AMP)
	CALL INTERP(RAMP)
	CALL INTERP(DOP)
C	CALL INTERP(CHNA)
C	CALL INTERP(CHNB)
C	CALL INTERP(CHNC)
C	CALL INTERP(CHND)
801	CONTINUE
	GO TO 937
99	CONTINUE
937	CALL MESS(E)
	CALL RDNUM(X)
	L=X
	IF(L.EQ.0)GO TO 200
	IF(L.GT.3)GO TO 937
	CALL HYDPOG(1)
	CALL HYDPOG(2)
C	CALL CLEAR
	CALL DPYSET(1,ST,50)
	CALL DPYBRT(1)
	CALL AIVECT(0,0)
	IF(L.EQ.3)GO TO 203
	CALL ALINE(-264,0,256,0)
	CALL ALINE(-256,-256,-256,256)
	CALL DPYOUT(1)
	CALL DPYSET(2,SU,350)
	CALL DPYBRT(6)
	CALL AIVECT(0,0)
	GO TO(201,202),L
201	IY=AMP(1)*256.
	CALL AIVECT(-256,IY)
	DO 301 I=2,512
	IY2=AMP(I)*256.0
	CALL SVECT(1,IY2-IY)
	IY=IY2
301	CALL DPYOUT(2)
	GO TO 99
202	IY=DOP(1)*256.-256.
	CALL AIVECT(-256,IY)
	DO 302 I=2,512
	IY2=DOP(I)*256.0-256.
	CALL SVECT(1,IY2-IY)
	IY=IY2
302	CALL DPYOUT(2)
	GO TO 99
203	CONTINUE
C	CALL CLEAR
	DO 300 J=-375,375,250
	CALL AIVECT(0,J)
	CALL RVECT(256,0)
	CALL RIVECT(-256,-125)
	CALL RVECT(0,250)
300	CALL DPYOUT(1)
	CALL DPYSET(2,SU,350)
	CALL DPYBRT(6)
	CALL AIVECT(0,0)
	IY=375
	CALL DRAW(CHNA,IY)
	IY=125
	CALL DRAW(CHNB,IY)
	IY=-125
	CALL DRAW(CHNC,IY)
	IY=-375
	CALL DRAW(CHND,IY)
	GO TO 99
200	CALL MESS(D)
	CALL RDNUM(X)
	IF(X.EQ.0.0)GO TO 307
	CALL HYDPOG(2)
	GO TO 101
307	CONTINUE
C	CALL CLEAR
	CALL DPYCLR
	RETURN
	END
CC******WAVE DRAWER**********************************************
	SUBROUTINE DRAW(FUNC,ICT)
	DIMENSION FUNC(512)
	CALL AIVECT(0,ICT)
	DO 100 I=1,512,4
	IY2=FUNC(I)*125.
	IF(I.GT.1)GO TO 10
	CALL RIVECT(0,IY2)
	GO TO 101
10	CALL SVECT(2,IY2-IY)
101	IY=IY2
100	CALL DPYOUT(2)
	RETURN
	END
CC******WAVE SMOOTHER********************************************
	SUBROUTINE INTERP(CFUNC)
	DIMENSION CFUNC(512)
	JT=0
	DO 601 KT=2,512
	IF(CFUNC(KT-1).NE.CFUNC(KT))GO TO 600
	IF(JT.EQ.0)JT=KT-1
	GO TO 601
600	IF(JT.EQ.0)GO TO 601
	DIFF=CFUNC(KT)-CFUNC(JT)
	DIV=KT-JT
	ANS=DIFF/DIV
	DO 602 LM=JT+1,KT-1
602	CFUNC(LM)=CFUNC(LM-1)+ANS
	JT=0
601	CONTINUE
	RETURN
	END